(define (make-printer)
  (let ((position 0))
    (list (lambda ()
	    position)
	  (lambda ()
	    (newline)
	    (set! position 0))
	  (lambda (x)
	    (let ((x (if (symbol? x) (symbol->string x)
			 (if (number? x) (number->string x)
			     (if (boolean? x)
				 (if x "#t" "#f")
				 x)))))
	      (display x)
	      (set! position (+ position (string-length x))))))))

(define (spaces display n)
  (if (= 0 n)
      #t
      (begin (display " ") (spaces display (- n 1)))))

(define (pretty-print form)
  (let* ((printer (make-printer))
	 (tell (car printer))
	 (newline (cadr printer))
	 (display (caddr printer)))
    (pretty-print^ tell newline display
		   (box '(0)) (box #f)
		   form)))

(define (box-push! b v)
  (set-box! b (cons v (unbox b))))
(define (box-pop! b)
  (let ((v (car (unbox b))))
    (set-box! b (cdr (unbox b)))
    v))

(define (hit-arity head)
  (cond ((member head '(begin define lambda let)) 0)
	((member head '(if)) 1)
	(else 0)))

(define (hit-return? head place)
  (or (and (member head '(begin)))
      (and (member head '(define lambda let)) (not (= 1 place)))
      (and (member head '(if)) (not (= 1 place)))))

(define %display display)

(define (pretty-print^ tell newline display levels newline? form)
  (let ((indent (lambda () (spaces display (car (unbox levels))))))
    (cond ((or (symbol? form)
	       (number? form)
	       (boolean? form))
	   (display form))
	  ((null? form)
	   (display "()"))
	  ((and (pair? form)
		(or (null? (cdr form)) (pair? (cdr form))))
	   (let ((ret-override #f))
	     (display "(")
	     (when (= (hit-arity (car form)) 0)
	       (box-push! levels (+ 1 (tell))))
	     (pretty-print^ tell newline display
			    levels newline?
			    (car form))
	     (let loop ((rest (cdr form)) (i 1))
	       (if (null? rest)
		   (begin
		     (display ")")
		     (box-pop! levels))
		   (begin
		     (if (or ret-override (hit-return? (car form) i))
			 (begin (set-box! newline? #t)
				(newline)
				(indent))
		       (begin
			 (display " ")
			 (when (= i (hit-arity (car form)))
			   (box-push! levels (tell)))))
		     (let ((prev-newline? (unbox newline?))
			   (ret-override-level #f))
		       (set-box! newline? #f)
		       (when (not ret-override)
			 (set! ret-override-level (tell)))
		       (pretty-print^ tell newline display
				      levels newline?
				      (car rest))
		       (when (not ret-override)
			 (set! ret-override (unbox newline?))
			 (when (and ret-override (= (hit-arity (car form)) 0))
			   (set-car! (unbox levels) ret-override-level)))
		       (set-box! newline? prev-newline?))
		     (loop (cdr rest) (+ i 1)))))))
	  ((pair? form)
	   (display "(")
	   (pretty-print^ tell newline display
			levels newline?
			(car form))
	   (display " . ")
	   (pretty-print^ tell newline display
			  levels newline?
			  (cdr form))
	   (display ")"))
	  (else (error 'pretty-print "unknown form" form)))))
